---
title: "lighthouse"
output:
flexdashboard::flex_dashboard:
theme: united
#social: menu
css: style2.css
source_code: embed
orientation: columns
vertical_layout: fill
---
```{r setup, include=FALSE}
library(flexdashboard)
library(broom)
library(DBI)
library(DT)
library(extrafont)
library(dplyr)
library(stringr)
library(lubridate)
library(leaflet)
library(leafgl)
library(crosstalk)
library(stargazer)
library(wesanderson)
library(plotly)
library(tidymodels)
knitr::opts_knit$set(root.dir = "~/R/lighthouse/R/")
knitr::opts_chunk$set(echo = F, cache = F, message = F, warning = F)
```
```{r load data,}
load("/mnt/D/Documents/Maitrise/Paper/Models/Data/models_db.RData")
wide_db <- models_db %>% select(!c("data")) %>% unnest(cols = c(OLI,S2A), names_sep="_") %>%
relocate(ID,PID,Station,Mission,DateTime,Lat,Lon,Depth)
wide_db <- wide_db %>% rename_with(~str_replace(.,"S2A","MSI"), starts_with("S2A"))
long_sensor <- wide_db %>% pivot_longer(cols = all_of(str_subset(names(wide_db),
"OLI|MSI")),
names_to = c("Sensor",".value"),
names_pattern = "(.+)_(.+)$")
long_sensorBand <- long_sensor %>% pivot_longer(cols = all_of(str_subset(names(long_sensor),
"B[:digit:]")),
names_to = "Band",
values_to = "Rrs",
values_drop_na = T
)
Sensor_nest <- long_sensor %>% group_by(Sensor) %>% nest()
```
```{r interpolation of IOP to common wl 394-700 nm}
IOP_long <- wide_db %>% pivot_longer(cols = all_of(str_subset(names(wide_db),
"A_|Ap_|Aph_|Ag_|Anap_|Bbp_|Bb_")),
names_to = c(".value","Lambda"),
names_pattern = "(.+)_(.+)",
values_drop_na = T
)
IOP_nest <- IOP_long %>% arrange(ID,Lambda) %>%
group_by(ID) %>% nest()
possibleApprox <- possibly(approx, otherwise=NULL)
ApproxIOP <- IOP_nest %>%
mutate(
A = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$A,.x$Lambda, na.rm = T))),
Ap = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Ap,.x$Lambda, na.rm = T))),
Aph = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Aph,.x$Lambda, na.rm = T))),
Anap = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Anap,.x$Lambda, na.rm = T))),
Ag = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Ag,.x$Lambda, na.rm = T))),
Bbp = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Bbp,.x$Lambda, na.rm = T))),
Bb = purrr::map(.x = data, ~ data.frame(possibleApprox(.x$Lambda,.x$Bb,.x$Lambda, na.rm = T))),
) %>%
select(ID,A,Ap,Aph,Anap,Ag,Bbp,Bb)
ApproxIOP <- ApproxIOP %>% dplyr::filter(purrr::map_lgl(A, ~ !is_empty(.)),
purrr::map_lgl(Ap, ~ !is_empty(.)),
purrr::map_lgl(Aph, ~ !is_empty(.)),
purrr::map_lgl(Anap, ~ !is_empty(.)),
purrr::map_lgl(Ag, ~ !is_empty(.)),
purrr::map_lgl(Bbp, ~ !is_empty(.)),
purrr::map_lgl(Bb, ~ !is_empty(.)))
ApproxIOP <- ApproxIOP %>% unnest(cols = c(A, Ap, Aph, Anap, Ag, Bbp, Bb), names_sep="_") %>% na.omit()
ApproxIOP <- ApproxIOP %>% select(A_x,!contains("x")) %>% mutate(
Lambda = as.numeric(A_x),
A = A_y,
Ap = Ap_y,
Aph = Aph_y,
Anap = Anap_y,
Ag = Ag_y,
Bbp = Bbp_y,
Bb = Bb_y
) %>% select(!contains(c("y","x")))
# Rrs at 9 wl give 255 731 row ... rather slow but working
# IOPgate <- long_sensorBand %>% filter(Sensor=="MSI") %>%
# select(matches("ID|ROI|Sensor|Band|Rrs|SPM|Ag_440")) %>%
# right_join(ApproxIOP, by="ID") %>%
# na.omit() %>% ungroup()
IOPgate <- wide_db %>%
select(matches("ID|ROI|SPM|Ag_440")) %>%
right_join(ApproxIOP, by="ID") %>%
na.omit() %>% ungroup()
IOPgate <-IOPgate %>% group_by(ID)
# ggplotly(IOPgate %>% ggplot(aes(x=Lambda, group=ID)) +
# geom_line(aes(y=Ag , color="Ag")) + geom_line(aes(y=Bbp, color="Bbp")) +
# geom_line(aes(y=Aph, color="Aph")) + geom_line(aes(y=Aph, color="Aph")) +
# geom_line(aes(y=Ap, color="Ap")) + geom_line(aes(y=Anap, color="Anap"))+
# geom_line(aes(y=A, color="A")) +
# theme(text=element_text(family="Times New Roman", face="bold", size=12)) +
# ylab("m-1"))
```
```{r sharedata objects}
sd_IOPs <- SharedData$new(IOPgate, key = ~ID, group = "IOPs")
subrrs <- long_sensorBand %>% filter(Sensor=="MSI") %>% select(matches("ID|Sensor|Band|Rrs|SPM"))
sd_rrs <- SharedData$new(subrrs, key = ~ID, group = "IOPs")
submap <- wide_db #%>% select(matches("ID|PID|Station|Mission|DateTime|Lat|Lon|Depth|SPM"))
sd_map <- SharedData$new(submap, group = "IOPs")
```
Dashboard
============
Column {.sidebar}
-----------------------------------------------------------------------
### filters
```{r}
filter_checkbox(id = "mission",
label = "Mission",
sharedData = sd_map,
group = ~Mission,
inline = T
)
filter_select(id = "ID",
label = "ID",
sharedData = sd_map,
group = ~ID
)
filter_select(id = "Station",
label = "Station",
sharedData = sd_map,
group = ~Station
)
filter_slider(id = "Depth",
label = "Station Depth",
sharedData = sd_map,
column = ~Depth
)
filter_slider(id = "SPM",
label = "SPM concentration",
sharedData = sd_map,
column = ~SPM
)
filter_slider(id = "Ag_440",
label = "CDOM concentration",
sharedData = sd_map,
column = ~Ag_440
)
```
Column {data-width=550}
-------------------------------------
### map
```{r map}
map <- leaflet(sd_map) %>%
addScaleBar("bottomright") %>%
addProviderTiles(provider = providers$CartoDB.Positron, group = 'Positron') %>%
addProviderTiles("Esri.WorldImagery", group = 'Aerial') %>%
addProviderTiles("OpenTopoMap", group = 'Terrain') %>%
addCircleMarkers(group = "Stations",
radius = 0.5,
color = "red",
popup = ~paste0('Station Details
',
'ID: ', ID, '
',
'PID: ', PID, '
',
'Station: ', Station, '
',
'DateTime: ', DateTime, '
',
'SPM: ', SPM, ' [mg.l-1]
',
'Depth: ', Depth, ' [m-1]
')
) %>%
addLayersControl(
baseGroups = c("Positron", "Aerial", "Terrain"),
overlayGroups = 'Stations',
options = layersControlOptions(collapsed = TRUE)
)
map
#bscols(widths = c(2, NA) ,Qfilter ,map)
# Cannot filter and cluster at the same time for now : https://github.com/rstudio/leaflet/issues/478
# clusterOptions = markerClusterOptions(disableClusteringAtZoom = 10)
```
Row {.tabset}
-------------------------------------
### Rrs for MSI
```{r}
prrs <- sd_rrs %>% plot_ly(x = ~Band, y = ~Rrs, text=~ID, colors=~ID) %>% add_lines()
prrs
```
### IOPs
```{r}
IOPs <- sd_IOPs %>%
plot_ly(x = ~Lambda, text=~ID) %>%
add_lines(y = ~A , color="A") %>%
add_lines(y = ~Ap , color="Ap") %>%
add_lines(y = ~Aph , color="Aph") %>%
add_lines(y = ~Anap , color="Anap") %>%
add_lines(y = ~Ag , color="Ag") %>%
add_lines(y = ~Bb , color="Bb") %>%
add_lines(y = ~Bbp , color="Bbp")
IOPs
```
### View grid display
```{r}
datatable(sd_map,
extensions = c("Buttons", "ColReorder"),
escape = TRUE, rownames = FALSE,
class = "cell-border stripe",
options = list(
dom = "Bfrtip", buttons = c("csv"), deferRender = TRUE,
scrollY = 50,
pageLength = 15,
scroller = TRUE,
colReorder = TRUE
)
)
```